govtrackR Analysis

Building Table to Explore PSCs

Lets build an an interactive table that lets us see all the PSCs

psc_tbl <- tbl_psc %>%
  select(
    is_active_psc,
    type_psc,
    name_solicitation_group,
    code_product_service,
    name_product_service,
    date_start,
    date_end,
    details_product_service_includes
  ) %>%
  reactable(
    filterable = T,
    resizable = T,
    searchable = T,
    showPageSizeOptions = T,
    defaultPageSize = 4,
    pageSizeOptions = c(5, 10, 20),
    sortable = T,
    compact = T
  )

Here it is

psc_tbl

Explore the Breakdown Between Products and Services

What is the breakdown between these two groups?

gg_psc_bkd <- 
  tbl_psc %>%
  count(type_psc, sort = T, name = "count") %>%
  mutate(type_psc = fct_reorder(type_psc, count)) %>%
  ggplot(aes(x = type_psc, y = count, fill = type_psc)) +
  geom_bar(stat = "identity", position = "dodge") +
  scale_fill_viridis(discrete = TRUE, name = "") +
  theme_ipsum() +
  ylab("Number of Product Service Codes") +
  xlab("") +
  ggtitle("Products Versus Services") +
  coord_flip()

gg_psc_bkd

New PSCs overtime

How often are new PSC’s added?

First, how many new PSC’s are there on a given date?

tbl_new_codes <-
  tbl_psc %>%
  group_by(type_psc, date_start) %>%
  summarise(count_added = n(), .groups = "drop")

Lets explore this interactively

hc_new_psc <-
  hchart(tbl_new_codes,
         "line",
         hcaes(x = date_start, y = count_added, group = type_psc)) %>%
  hc_title(text = "New Product Service Codes by Date Added") %>%
  hc_yAxis(title = list(text = "Count of New Codes")) %>%
  hc_xAxis(title = list(text = "Date Added"))

hc_new_psc

Lets make this look a bit better

hc_new_psc <-
  hc_new_psc %>%
  hc_add_theme(hc_theme_hcrt())

hc_new_psc

Build A Network Graph of the 10 Newest PSCs

Lets take a look at the 10 newest PSCs

tbl_10_new_psc <-
  tbl_psc %>%
  filter(!is_parent_psc) %>%
  arrange(desc(date_start)) %>%
  group_by(type_psc) %>%
  slice(1:10) %>%
  ungroup()

gt(tbl_10_new_psc)

Build a Network Graph of these New PSCs

Lets explore the connections of these 20 newest PSCs

hc_new_psc_node_graph <-
  tbl_10_new_psc %>%
  select(name_solicitation_group, name_product_service) %>%
  as_tbl_graph() %>%
  hchart() %>%
  hc_title(text = "New Product Service Codes Node Graph") %>%
  hc_add_theme(hc_theme_darkunica()) %>%
  hc_xAxis(visible = FALSE) %>%
  hc_yAxis(visible = FALSE)

hc_new_psc_node_graph

Acquire All Procurements of Pyrotechnics

tbl_pyro <-
  fpds_csv(product_or_service_code = "1370", snake_names = T)

Explore the Data Structure and Values

This is a great practice for exploring data

glimpse(tbl_pyro)

Rows: 6,118 Columns: 43 $ id_contract “16680197810D0001N0016477C0003”, “166… $ date_obligation 1978-10-15, 1978-11-15, 1978-11-15, … $ id_contract_analysis ”16680197810D0001N0016477C0003“,”166… $ type_procurement “AWARD”, “AWARD”, “AWARD”, “AWARD”, “… $ id_contract_idv ”N0016477C0003“,”N0016477C0028“,”N0… $ code_modification “0”, “0”, “0”, “0”, “0”, “0”, “0”, “0… $ number_transaction 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0… $ type_award ”DCA DEFINITIVE CONTRACT“,”DCA DEFIN… $ amount_obligation 19000, 17000, 24000, 44000, 2739000, … $ date_solicitation NA, NA, NA, NA, NA, NA, NA, NA, NA, … $ id_agency_award “1700”, “1700”, “1700”, “1700”, “2100… $ name_agency_award ”DEPARTMENT OF THE NAVY“,”DEPARTMENT… $ name_office_award “NAVAL WEAPONS SUPPLY CENTER”, “NAVAL… $ type_product_or_service ”P“,”P“,”P“,”P“,”P“,”P“,”P“,”P… $ code_product_service “1370”, “1370”, “1370”, “1370”, “1370… $ id_naics NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ name_naics NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ id_duns NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ name_vendor ”S.N.C. SCIONTI“,”S.N.C. SCIONTI“,”… $ city_vendor NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ code_state_vendor NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ zipcode_vendor NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ id_duns_parent NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ name_vendor_parent “S.N.C. SCIONTI”, “S.N.C. SCIONTI”, “… $ code_additional_reporting NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ description_additonal_reporting NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ url_csv ”https://www.fpds.gov/ezsearch/fpdspo… $ year_fiscal_obligation 1978, 1978, 1978, 1978, 1978, 1978, 1… $ has_duns_parent FALSE, FALSE, FALSE, FALSE, FALSE, FA… $ is_missing_duns TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, T… $ id_department_award “9700”, “9700”, “9700”, “9700”, “9700… $ name_department_award ”DEPARTMENT OF DEFENSE“,”DEPARTMENT … $ code_department_award 97, 97, 97, 97, 97, 97, 97, 97, 97, 9… $ type_contract_id_analysis “CONTRACT”, “CONTRACT”, “CONTRACT”, “… $ id_cgac_award 17, 17, 17, 17, 21, 21, 21, 21, 17, 2… $ name_agency_cgac_award ”DEPARTMENT OF THE NAVY“,”DEPARTMENT… $ slug_cgac_award “017”, “017”, “017”, “017”, “021”, “0… $ type_psc ”PRODUCT“,”PRODUCT“,”PRODUCT“,”PRO… $ name_product_service “PYROTECHNICS”, “PYROTECHNICS”, “PYRO… $ id_solicitation_group ”13“,”13“,”13“,”13“,”13“,”13“,”… $ name_solicitation_group “AMMUNITION AND EXPLOSIVES”, "AMMUNIT… $ has_parent NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ is_idv TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, T…

skim(tbl_pyro)

Variable type: character

Variable type: Date

Variable type: logical

Variable type: numeric

What is the Total Spend?

First thing to look at is how much we have spent on these products.

tbl_by_day <- 
  tbl_pyro %>%
  group_by(date_obligation) %>%
  summarise(amount = sum(amount_obligation), .groups = "drop")

Lets take a look at the data

tbl_by_day %>% sample_n(3) %>% munge_data() %>% gt()

Dealing with $0 Obligations

tbl_by_day %>% filter(amount == 0) %>% nrow()

[1] 879

Lets filter them out

tbl_by_day <- tbl_by_day %>% filter(amount != 0)

Explore Outlays by Day

hc_by_day <-
  tbl_by_day %>%
  hchart("spline",
         hcaes(x = date_obligation, y = amount)) %>%
  hc_title(text = "Pyrotechnic Spend By Day Spend by Date") %>%
  hc_yAxis(title = list(text = "Amount Obligated")) %>%
  hc_xAxis(title = list(text = "Date Added")) %>%
  hc_add_theme(hc_theme_elementary())

What is the Cumulative Spend?

Lets add a cumulative total

tbl_by_day <-
  tbl_by_day %>%
  mutate(amount_cumulative = cumsum(amount))

Now lets explore it statically

gg_area_pyro <-
  tbl_by_day %>%
  ggplot(aes(date_obligation, amount_cumulative)) +
  geom_area(fill = "#22908C", alpha = .5) +
  scale_fill_viridis(discrete = TRUE) +
  scale_y_continuous(labels = scales::dollar) +
  scale_x_date() +
  theme(legend.position = "none") +
  theme_ipsum() +
  labs(title = "Cumulative Federal Procurement on Pyrotechnics", x = "Date", y = "Cumulative Procurement Spend")

gg_area_pyro

Lets add some model fits

gg_area_pyro <- 
  gg_area_pyro +
  geom_smooth(method = "lm") +
  geom_smooth(method = "loess", color = "black") 

gg_area_pyro

Do these Procurments Exhibit Seasonality?

Often products and services tend to be procured in September at the end of the budget year, does this product exhibit that trend?

Lets build a table that gives us the inputs

govt_months <- 
  c(
    "Oct",
    "Nov",
    "Dec",
    "Jan",
    "Feb",
    "Mar",
    "Apr",
    "May",
    "Jun",
    "Jul",
    "Aug",
    "Sep"
  )

tbl_monthly_pyro <-
  tbl_pyro %>%
  mutate(month_obligation = lubridate::month(date_obligation, label = T)) %>%
  count(year_fiscal_obligation,
        month_obligation,
        wt = amount_obligation,
        name = "amount")

## Set the factor levels to budget months

tbl_monthly_pyro <- 
  tbl_monthly_pyro %>%
  mutate(month_obligation = factor(
    month_obligation,
    levels = govt_months,
    ordered = T
  ))

Lets turn this into an interactive heatmap.

fntltp <- JS("function(){
  return this.point.x + ' ' +  this.series.yAxis.categories[this.point.y] + ': ' +
  Highcharts.numberFormat(this.point.value, 2);
}")


hc_pyro_hm <-
  hchart(
    tbl_monthly_pyro,
    "heatmap",
    hcaes(x = year_fiscal_obligation,
          y = month_obligation,
          value = amount)
  ) %>%
  hc_colorAxis(
    stops = color_stops(20, colors = scales::viridis_pal(option = "B")(20)),
    # fuerza a utilzar mejor el espectro de colores para que HJS no amplie el
    # eje para tener numero "redondos
    startOnTick = FALSE,

    endOnTick =  FALSE,
    reversed = T
  ) %>%
  hc_yAxis(
    title = list(text = ""),
    reversed = TRUE,
    offset = -20,
    tickLength = 0,
    gridLineWidth = 0,
    minorGridLineWidth = 0,
    labels = list(style = list(fontSize = "9px"))
  ) %>%
  hc_tooltip(formatter = fntltp) %>%
  hc_title(text = "Spend by Month and Fiscal Year") %>%
  hc_legend(
    layout = "horizontal",
    verticalAlign = "top",
    align = "left",
    valueDecimals = 0
  ) %>%
  hc_add_theme(hc_theme_darkunica())

hc_pyro_hm

Looks like it fits the usual trend but can we actually quantify it?

Lets do a basic liner model exploring this.

mod <-
  rtemis::s.LM(x = tbl_monthly_pyro$month_obligation, y = tbl_monthly_pyro$amount, intercept = F)

[2020-11-05 16:14:51 rtemis::s.LM] Hello, alexbresler

[[ Regression Input Summary ]] Training features: 497 x 1 Training outcome: 497 x 1 Testing features: Not available Testing outcome: Not available

[2020-11-05 16:14:51 rtemis::s.LM] Training linear model…

[[ LM Regression Training Summary ]] MSE = 2.7e+14 (8.55%) RMSE = 1.6e+07 (4.37%) MAE = 1e+07 (4.84%) r = 0.29 (p = 3e-11) rho = 0.33 (p = 4.1e-14) R sq = 0.09 [2020-11-05 16:14:51 rtemis::s.LM] Run completed in 0.01 minutes (Real: 0.61; User: 0.38; System: 0.08)

Now lets explore the variable importance!

var_imp <- mod$varimp
tbl_coef <- 
  tibble(month = names(var_imp), amount_coef = var_imp) %>%
  arrange(desc(amount_coef)) %>%
  munge_data()

Let’s see

gt(tbl_coef)

Spend by Department

Lets take a look at spend by department.

tbl_depts <-
  tbl_pyro %>%
  count(
    name_department_award,
    wt = amount_obligation,
    name = "amount",
    sort = T
  ) %>%
  mutate(name_department_award = fct_reorder(name_department_award, amount))

tbl_depts %>% munge_data() %>% gt()

Now we can visualize it.

gg_spend <-
  tbl_depts %>%
  mutate(amount_millions = amount /1000000) %>% 
  ggplot(aes(x = name_department_award, y = amount_millions)) +
  geom_segment(
    aes(
      x = name_department_award ,
      xend = name_department_award,
      y = 0,
      yend = amount_millions
    ),
    color = "grey"
  ) +
  geom_point(size = 3, color = "#69b3a2") +
  coord_flip() +
  theme_ipsum() +
  theme(
    legend.position = "none",
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_blank(),
    text = element_text(size = 7)
  ) +
  xlab("") +
  scale_y_log10(labels = scales::dollar, n.breaks = 10) +
  labs(title = "Which Departments Purchased the Explosives?",
       x = "",
       y = "Procurement $ in milions (log10 transformed)")

gg_spend

Contract Size by Agency Group

Now lets look at contract size against agency group.

tbl_pyro %>%
  filter(amount_obligation > 0) %>% count(name_agency_cgac_award,
                                          wt = amount_obligation,
                                          sort = T,
                                          name = "amount") %>%
  munge_data() %>%
  gt()

Looks like it is really skewed to a few agencies. Perfect situation to lump some of the groups

tbl_agency_sum <- 
  tbl_pyro %>%
  filter(amount_obligation > 0) %>%
  mutate(
    name_agency_cgac_award = name_agency_cgac_award %>% fct_lump(8, w = amount_obligation, other_level = "OTHER 6 AGENCIES")
  ) %>%
  group_by(name_agency_cgac_award, id_contract_analysis) %>%
  summarise(amount = sum(amount_obligation, na.rm = T)) %>%
  ungroup() %>%
  filter(amount > 1000) %>%
  mutate(name_agency_cgac_award = fct_reorder(name_agency_cgac_award, amount)) 

Now we can explore the range using a boxplot and even layer in the volume with a scatter plot!

gg_contract <- 
  tbl_agency_sum %>%
  ggplot(aes(
    x = factor(name_agency_cgac_award),
    y = amount,
    fill = name_agency_cgac_award
  )) +
  geom_boxplot() +
  geom_jitter(color = "black",
              size = 0.3,
              alpha = .5)  +
  scale_fill_viridis(discrete = TRUE, alpha = .5) +
  theme_ipsum() +
  scale_y_log10(labels = scales::dollar) +
  theme(legend.position = "none",
        plot.title = element_text(size = 11)) +
  labs(
    title = "Distrubition of Award Size by Agency Group",
    x = "",
    y = "",
    credits = "Awards over $1000"
  ) +
  coord_flip()

gg_contract

How Do We Procure Pyrotechnics

Next lets see how the government procures this product and visualize it in a treemap.

Lets set the treemap parameters

lvl_opts <-  list(
  list(
    level = 1,
    borderWidth = 0,
    borderColor = "transparent",
    dataLabels = list(
      enabled = TRUE,
      align = "left",
      verticalAlign = "top",
      style = list(
        fontSize = "12px",
        textOutline = FALSE,
        color = "white"
      )
    )
  ),
  list(
    level = 2,
    borderWidth = 0,
    borderColor = "transparent",
    colorVariation = list(key = "brightness", to = 0.250),
    dataLabels = list(enabled = T),
    style = list(
      fontSize = "8px",
      textOutline = FALSE,
      color = "white"
    )
  )
)

Now we can build the treemap

hc_treemap_spend <-
  tbl_pyro %>%
  count(name_department_award, type_award, sort = T) %>%
  highcharter::data_to_hierarchical(
    group_vars = c("name_department_award", "type_award"),
    size_var = "n"
  ) %>%
  hchart(
    type = "treemap",
    levels = lvl_opts,
    tooltip = list(valueDecimals = FALSE)
  ) %>%
  hc_add_theme(hc_theme_superheroes())

hc_treemap_spend

Deepive: Pyrotechnic Vendors

Next lets take a look at the companies that supply this product.

First thing we want to do is build a summary table that lets us explore the data.

tbl_vendors <- 
  tbl_pyro %>%
  group_by(id_duns) %>%
  summarise(
    name_vendor = name_vendor[which.max(amount_obligation)],
    date_first_award = min(date_obligation, na.rm = T),
    date_recent_award = max(date_obligation, na.rm = T),
    count_actions = n(),
    count_contracts = n_distinct(id_contract_analysis, na.rm = T),
    amount_contracts = sum(amount_obligation),
    count_departments = n_distinct(name_department_award, na.rm = T),
    count_agencies = n_distinct(name_agency_cgac_award, na.rm = T)
  ) %>%
  arrange(desc(amount_contracts))

Who are the top 10 vendors?

tbl_vendors %>%
  slice(1:10) %>%
  munge_data() %>%
  gt()

Lets skim the data

skim(tbl_vendors)

Variable type: character

Variable type: Date

Variable type: numeric

Lets filter our data to include only vendors with over $500,000 in obligations.

tbl_vendors <- tbl_vendors %>% filter(amount_contracts > 500000)

Now lets take a look at the top vendors visually.

gg_top_vendors_pyro <-
  tbl_vendors %>%
  filter(amount_contracts > 0) %>%
  mutate(
    name_vendor_lumped = name_vendor %>% fct_lump(10, w = amount_contracts, other_level = "ALL OTHER VENDORS")
  ) %>%
  count(name_vendor_lumped, wt = amount_contracts, name = "amount") %>%
  mutate(name_vendor_lumped = fct_reorder(name_vendor_lumped, amount)) %>%
  ggplot(aes(x = name_vendor_lumped, y = amount)) +
  geom_bar(stat = "identity", fill = "#B71212") +
  coord_flip() +
  theme_ipsum() +
  theme(
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_blank(),
    legend.position = "none"
  ) +
  xlab("") +
  labs(title = "Top Explosive Vendors") +
  scale_y_continuous(labels = scales::dollar, n.breaks = 10)

gg_top_vendors_pyro

Lets try to figure out how many clusters exist. We should transform the x and y axis to make it easier to process visually.

Lets try 4 clusters

mplot3.xy(
  log(tbl_vendors$count_actions),
  log(tbl_vendors$amount_contracts / 1000000),
  cluster = "PAM",
  cluster.params = list(k = 4),
  main = "Contracts Actions vs Contract $ by PAM Cluster Group",
  fit = "lm",
  xlab = "Contract Actions",
  ylab = "Contract $ (millions)",
  theme = "white"
)

Looks Good!

Now lets take a look at a normalzied view of all of the key vendor features.

tbl_vendors %>%
  select(-c(id_duns)) %>%
  select_if(is.numeric) %>%
  preprocess(scale = T) %>%
  mplot3.x(group.title = "Normalized Numeric Feature Distributions [Explosive Vendors - Over $500k in Obligations]",
           theme = 'white',
           density.line = T)

[2020-11-05 16:15:03 preprocess] Scaling 5 numeric features… [2020-11-05 16:15:03 preprocess] Done

Deepdive: Dimension Reduction Award Offices

First we need to build an input table with the data on the dimensions to be reduced

tbl_pyro_office <- 
  tbl_pyro %>%
  group_by(name_office_award) %>%
  summarise(
    department = name_department_award[which.max(amount_obligation)],
    agency = name_agency_cgac_award[which.max(amount_obligation)],
    year_first = year(date_obligation) %>% min(),
    date_recent_award = year(date_obligation) %>% max(),
    count_actions = n(),
    count_contracts = n_distinct(id_contract_analysis, na.rm = T),
    amount_contracts = sum(amount_obligation),
    count_distinct_vendors = n_distinct(id_duns, na.rm = T),
    count_distinct_parents = n_distinct(id_duns_parent, na.rm = T),
    .groups = "drop"
  ) %>%
  arrange(desc(amount_contracts))

tbl_pyro_office <-
  tbl_pyro_office %>%
  mutate(agency_lumped = fct_lump(agency, n = 6, other_level = "ALL OTHER AGENCIES"))

reactable(tbl_pyro_office, filterable = F,
    resizable = T,
    searchable = T,
    showPageSizeOptions = T,
    pageSizeOptions = c(5, 10, 20),
    sortable = T,
    )

tbl_umap <-
  tbl_pyro_office %>%
  select_if(is.numeric) %>%
  uwot::umap(n_neighbors = 14, metric = "manhattan") %>%
  as_tibble() %>% 
  setNames(c("umap_001", "umap_002"))


tbl_pyro_office <- 
  tbl_pyro_office %>% 
  bind_cols(
    tbl_umap
  )

Finally we can visualize the output.

x <-
  c(
    "Department",
    "Agency",
    "Office",
    "Contracts",
    "Vendors",
    "Amount $",
    "Actions",
    "umap 1",
    "umap 2"
  )

y <-
  sprintf(
    "{point.%s:.2f}",
    c(
      "department",
      "agency",
      "name_office_award",
      "count_actions",
      "count_distinct_vendors",
      "amount_contracts",
      "count_actions",
      "umap_001",
      "umap_002"
    )
  )

tltip <- tooltip_table(x, y)


hc_umap <-
  tbl_pyro_office %>%
  hchart(
    "scatter",
    hcaes(
      x = umap_001,
      y = umap_002,
      group = agency_lumped,
      name = name_office_award
    ),
    marker = list(radius = 1, symbol = 'circle')
  ) %>%
  hc_add_theme(hc_theme_darkunica()) %>%
  hc_xAxis(visible = F) %>%
  hc_yAxis(visible = F) %>%
  hc_title(text = "Pyrotechnic Office Dimension Reduction") %>%
  hc_tooltip(
    useHTML = TRUE,
    headerFormat = "{point.name}",
    pointFormat = tltip,
    table = T
  )

hc_umap

Function Base Paramaters

args(fpds_atom)

function (global_vendor_name = NA, vendor_name = NA, parent_vendor_name = NA, department_name = NA, award_type = NA, research = NA, vendor_duns_number = NA, parent_duns_number = NA, vendor_doing_business_as_name = NA, agency_name = NA, contracting_office_name = NA, contracting_agency_name = NA, principal_naics_code = NA, award_status = NA, subcontract_plan = NA, solicitation_procedure = NA, contract_type = NA, contract_type_description = NA, type_of_contract_pricing = NA, contract_id = NA, ref_idv_contract_id = NA, ref_idv_agency_id = NA, contracting_agency_id = NA, contracting_office_id = NA, funding_agency_id = NA, funding_office_id = NA, funding_office_name = NA, agency_code = NA, department_id = NA, last_mod_date = NA, last_modified_by = NA, award_completion_date = NA, created_date = NA, signed_date = NA, effective_date = NA, estimated_completion_date = NA, cancellation_date = NA, destroy_date = NA, final_invoice_paid_date = NA, funded_through_date = NA, last_modified_date = NA, physical_completion_date = NA, reveal_date = NA, solicitation_issue_date = NA, sys_last_modified_date = NA, vendor_registration_date = NA, vendor_renewal_date = NA, base_exercised_options_value = NA, current_contract_value = NA, dollars_obligated = NA, contract_value = NA, fee_range_lower_value = NA, fee_range_upper_value = NA, fixed_fee_value = NA, obligated_amount = NA, total_current_contract_value = NA, total_dollars_obligated = NA, total_non_government_value = NA, total_ultimate_contract_value = NA, ultimate_contract_value = NA, contract_fiscal_year = NA, created_by = NA, description_of_requirement = NA, reason_for_modification = NA, legislative_mandates = NA, local_area_set_aside = NA, socio_economic_indicators = NA, multiyear_contract = NA, national_interest_code = NA, product_or_service_code = NA, performance_district_code = NA, performance_country = NA, performance_state_name = NA, vendor_address_city = NA, vendor_congress_district_code = NA, vendor_address_country_code = NA, vendor_address_country_name = NA, vendor_address_state_code = NA, vendor_address_state_name = NA, vendor_address_zip_code = NA, extent_competed = NA, number_of_offers_received = NA, sort_item = “Signed Date”, use_future = F, show_progress = T, clean_address = T, clean_entity_column = T, sort_descending = T, parse_contracts = F, snake_names = F, keep_key_columns = F, exclude_bloat = F, unformat = T, return_message = T, …) NULL

Acquire All Procurements for Anduril

tbl_anduril <-
  fpds_atom(
    vendor_name = "ANDURIL",
    parse_contracts = T,
    snake_names = T
  )

Lets explore the data

glimpse(tbl_anduril)

Rows: 43 Columns: 334 $ id_contract_analysis … $ id_contract … $ date_obligation … $ id_duns … $ id_duns_parent … $ id_duns_analysis … $ id_contract_idv … $ name_contract … $ description_obligation … $ datetime_contract_modified … $ name_vendor … $ name_vendor_parent … $ address_street1vendor … $ cage_vendor … $ city_vendor … $ code_congressional_district_vendor … $ code_country_vendor … $ code_site_alternate_vendor_vendor … $ code_site_vendor_vendor … $ code_state_vendor … $ telephone_vendor … $ zipcode_vendor … $ name_state_vendor … $ code_consolidated_contract … $ date_contract_completion_current … $ date_contract_completion_ultimate … $ date_contract_effective … $ date_registration_sam … $ date_renewal_sam … $ datetime_transaction_approved … $ datetime_transaction_created … $ datetime_transaction_last_modified … $ type_consolidated_contract … $ amount_base_all_option … $ amount_base_all_option_total … $ amount_base_and_exercised_option … $ amount_base_and_exercised_option_total … $ amount_fee_paid_for_service … $ amount_obligation … $ amount_obligation_total … $ amount_estimated_total … $ amount_individual_order_limit … $ amount_non_governmental_dollars … $ id_agency_funding … $ name_agency_award … $ name_agency_award_idv … $ name_agency_funding … $ id_agency_award … $ id_agency_award_idv … $ code_inter_agency_contracting_authority … $ is_federal_government_agency … $ type_inter_agency_contracting_authority … $ name_office_award … $ name_office_funding … $ id_office_award … $ id_office_funding … $ code_contracting_officer_business_size_determination … $ type_contracting_officer_business_size_determination … $ id_naics … $ name_naics … $ code_country_origin_product_service … $ code_product_service … $ name_country_origin_product_service … $ name_product_service … $ count_actions … $ count_offers_received_idv … $ count_offers_received … $ url_fpds_contract_atom … $ code_action … $ code_additional_reporting_value … $ code_commercial_acquisition_procedures … $ code_congressional_district_performance … $ code_contract_bundling … $ code_contract_competition … $ code_cost_pricing_data … $ code_country_incorporation … $ code_country_performance … $ code_domestic_foreign_entity … $ code_epa_designated_product … $ code_evaluated_preference … $ code_humanitarian_peackeeping_operation … $ code_idv_set_aside … $ code_inherently_government_function … $ code_list_of_additional_reporting_values … $ code_manufacturing_organization … $ code_materials_supplies_articles_equipment … $ code_modification … $ code_modification_idv … $ code_multiple_or_single_idv … $ code_national_interest_action … $ code_offers_source … $ code_performance_based_service_contract … $ code_place_of_manufacture … $ code_recovered_materials … $ code_referenced_idv … $ code_research … $ code_set_aside_source … $ code_solicitation_procedures … $ code_state_incorporation … $ code_state_performance … $ code_status_transaction … $ code_sub_contract_plan … $ code_undefinitized_action … $ generic_string06 … $ has_a76fair_act_action … $ has_clinger_cohen_act_planning … $ has_construction_wage_requirements … $ has_contracts … $ has_contracts_and_grants … $ has_cost_or_pricing_data … $ has_credit_card_purchase_method … $ has_gfe_or_gfp … $ has_grants … $ is1862land_grant_college … $ is1890land_grant_college … $ is1994land_grant_college … $ is_airport_authority … $ is_alaskan_native_owned_corporation_or_firm … $ is_alaskan_native_servicing_institution … $ is_american_indian_owned … $ is_asian_pacific_american_owned_business … $ is_black_american_owned_business … $ is_city_local_government … $ is_commercial_item_test_program … $ is_community_developed_corporation_owned … $ is_community_developed_corporation_owned_firm … $ is_community_development_corporation … $ is_corporate_entity_not_tax_exempt … $ is_corporate_entity_tax_exempt … $ is_council_of_governments … $ is_county_local_government … $ is_domestic_shelter … $ is_dot_certified_disadvantaged_business_enterprise … $ is_economically_disadvantaged_women_owned_small_business … $ is_educational_institution … $ is_federal_government … $ is_federally_funded_research_and_development_corp … $ is_foreign_government … $ is_foreign_owned_and_located … $ is_for_profit_organization … $ is_foundation … $ is_hispanic_american_owned_business … $ is_hispanic_servicing_institution … $ is_historically_black_college_or_university … $ is_hospital … $ is_housing_authorities_public_or_tribal … $ is_indian_tribe_owned … $ is_inter_municipal_local_government … $ is_international_organization … $ is_interstate_entity … $ is_joint_venture_economically_disadvantaged_women_owned_small_business … $ is_joint_venture_women_owned_small_business … $ is_labor_surplus_area_firm … $ is_limited_liability_corporation … $ is_local_area_set_aside … $ is_local_government … $ is_local_government_owned … $ is_manufacturer_of_goods … $ is_minority_institution … $ is_minority_owned … $ is_multi_year_contract … $ is_municipality_local_government … $ is_native_american_owned_business … $ is_native_hawaiian_owned_organization_or_firm … $ is_native_hawaiian_servicing_institution … $ is_nonprofit_organization … $ is_other_minority_owned … $ is_other_not_for_profit_organization … $ is_partnership_or_limited_liability_partnership … $ is_planning_commission … $ is_port_authority … $ is_private_university_or_college … $ is_sba_certified8a_joint_venture … $ is_sba_certified8a_program_participant … $ is_sba_certified_hub_zone … $ is_sba_certified_small_disadvantaged_business … $ is_school_district_local_government … $ is_school_of_forestry … $ is_self_certified_hub_zone_joint_venture … $ is_self_certified_small_disadvantaged_business … $ is_service_related_disabled_veteran_owned_business … $ is_sheltered_workshop … $ is_small_agricultural_cooperative … $ is_small_business … $ is_sole_propreitorship … $ is_state_controlled_institution_of_higher_learning … $ is_state_government … $ is_subchapter_s_corporation … $ is_sub_continent_asian_american_owned_business … $ is_township_local_government … $ is_transaction_closed … $ is_transit_authority … $ is_tribal_college … $ is_tribal_government … $ is_tribally_owned_firm … $ is_us_government_entity … $ is_very_small_business … $ is_veteran_owned … $ is_veterinary_college … $ is_veterinary_hospital … $ is_women_owned … $ is_women_owned_small_business … $ number_transaction … $ transaction_approved_by … $ transaction_created_by … $ transaction_last_modified_by … $ type_organization … $ zipcode_performance … $ name_country_incorporation … $ name_country_performance … $ name_state_incorporation … $ name_state_performance … $ type_a76fair_act_action … $ type_action … $ type_additional_reporting_value … $ type_clinger_cohen_act_planning … $ type_commercial_acquisition_procedures … $ type_commercial_item_test_program … $ type_construction_wage_requirements … $ type_contract_bundling … $ type_contract_competition … $ type_cost_or_pricing_data … $ type_cost_pricing_data … $ type_credit_card_purchase_method … $ type_domestic_foreign_entity … $ type_epa_designated_product … $ type_evaluated_preference … $ type_fbo_sourced … $ type_gfe_or_gfp … $ type_humanitarian_peackeeping_operation … $ type_idv_set_aside … $ type_inherently_government_function … $ type_labor_standards_clause … $ type_local_area_set_aside … $ type_manufacturing_organization … $ type_materials_supplies_articles_equipment … $ type_multiple_or_single_idv … $ type_multi_year_contract … $ type_national_interest_action … $ type_offers_source … $ type_performance_based_service_contract … $ type_place_of_manufacture … $ type_recovered_materials … $ type_referenced_idv … $ type_research … $ type_set_aside_source … $ type_solicitation_procedures … $ type_status_transaction … $ type_sub_contract_plan … $ type_undefinitized_action … $ code_contract_financing … $ code_contract_modification … $ code_cost_accounting_clause … $ code_equipment_system … $ code_not_compete_reason … $ code_program_claimant … $ code_set_aside … $ code_technology_item … $ pct_price_difference_price_evaluation … $ type_contract_financing … $ type_contract_modification … $ type_cost_accounting_clause … $ type_equipment_system … $ type_not_compete_reason … $ type_program_claimant … $ type_sea_transported … $ type_set_aside … $ type_technology_item … $ code_idc … $ code_idc_contract … $ code_who_can_use … $ id_solicitation … $ type_idc … $ type_idc_contract … $ code_non_traditional_government_contractor_participation … $ type_agreement … $ year_fiscal_contract … $ type_non_traditional_government_contractor_participation … $ url_fpds_atom … $ has_contract_parent … $ is_idv … $ location_vendor … $ city_state_vendor … $ location_performance … $ has_duns_parent … $ is_missing_duns … $ year_budget … $ id_department_award … $ name_department_award … $ code_department_award … $ id_department_funding … $ name_department_funding … $ code_department_funding … $ type_dod_award … $ type_contract_id_analysis … $ id_cgac_funding … $ name_agency_cgac_funding … $ slug_cgac_funding … $ id_cgac_award … $ name_agency_cgac_award … $ slug_cgac_award … $ id_cgac_agency_idv … $ name_cgac_agency_idv … $ slug_cgac_agency_idv … $ names_vendor_listed … $ count_vendors_listed … $ has_multiple_vendors … $ names_vendor_parent_listed … $ count_vendors_parent_listed … $ has_multiple_parent_vendors … $ is_possible_sbirsttr … $ is_filtered_sbir … $ has_labor_standards_clause … $ is_fbo_sourced … $ is_sea_transported … $ datetime_transaction_closed … $ code_fee_for_use_of_service … $ email_contract … $ url_website … $ type_fee_for_use_of_service … $ transaction_closed_by … $ slug_agency_funding … $ slug_office_funding … $ id_federal_account … $ code_account_omb … $ code_treasury_account_symbol … $ id_cgac … $ code_treasury_sub_account_symbol … $ id_initiative … $ name_initiative … $ id_federal_account_resolved … $ amount_obligation_allocated … $ has_federal_account … $ fax_vendor …

skim(tbl_anduril)

Variable type: character

Variable type: Date

Variable type: logical

Variable type: numeric

Variable type: POSIXct

Lets remove excess features.

tbl_anduril <-
  tbl_anduril %>% preprocess(removeConstants = T) %>% as_tibble()

[2020-11-05 16:16:56 preprocess] Removing constant features… [2020-11-05 16:16:56 preprocess] Done

Lets make sure we have the Anduril we are looking for.

tbl_count <- 
  tbl_anduril %>%
  count(name_vendor, id_duns, name = "count_actions")

gt(tbl_count)

Looks like there is another vendor that isn’t who we are interested in. Lets exclude them.

tbl_anduril <-
  tbl_anduril %>%
  filter(id_duns != 103307059)

Anduril Awards by Agency and Year

gt_dept <- 
  tbl_anduril %>%
  count(name_agency_cgac_award,
        year_budget,
        wt = amount_obligation,
        name = "amount") %>%
  arrange(desc(amount)) %>% 
  munge_data() %>% 
  gt()

gt_dept

Anduril Award Description Analysis

One of the biggest benefits of fpds_atom is that it gives access to procurement text descriptions. Lets take a look at them for Anduril and see what 2 sets of words show up together and visualize them in a network graph.

stop_words <- get_stopwords(source = "smart")

tidy_ngram <-
  tbl_anduril %>%
  select(id_contract_analysis,
         description_obligation,
         amount_obligation) %>%
  unnest_tokens(bigram,
                description_obligation,
                token = "ngrams",
                n = 2)

Next we can filter out stop words and build our bigram count table.

bigram_counts <-
  tidy_ngram %>%
  separate(bigram, c("word1", "word2"), sep = " ") %>%
  filter(!word1 %in% stop_words$word,
         !word2 %in% stop_words$word) %>%
  count(word1, word2, sort = TRUE)

gg_bigraph <-
  bigram_counts %>%
  filter(!is.na(word1)) %>%
  graph_from_data_frame() %>%
  ggraph(layout = "nicely") +
  geom_edge_link(
    aes(edge_alpha = n),
    show.legend = FALSE,
    arrow = arrow(length = unit(1.5, 'mm')),
    start_cap = circle(3, 'mm'),
    end_cap = circle(3, 'mm')
  ) +
  geom_node_text(aes(label = name)) +
  theme_graph() +
  labs(title = "Anduril FPDS Description Bigram")

gg_bigraph

Anduril Trigram Award Totals

Next lets take a look at which 3 words show up together and how many contracts this and obligations they correspond to.

First we build the ngram table

tbl_ngrams <-
  tbl_anduril %>%
  select(id_contract_analysis,
         description_obligation,
         amount_obligation) %>%
  unnest_tokens(ngram, description_obligation, token = "ngrams", n = 3)

Next we build the summary

 tbl_ngrams <- 
  tbl_ngrams %>%
  group_by(ngram) %>%
  summarise(
    amount = sum(amount_obligation),
    count_contracts = n_distinct(id_contract_analysis)
  ) %>%
  arrange(desc(amount)) %>% 
  munge_data()

Lets look at the top 15

tbl_ngrams %>% 
  slice(1:15) %>% 
  gt()

Acquire All Phase III SBIR Procurements

df_all <-
  fpds_research_csv(research_codes = c("SR3", "ST3"),
                    snake_names = T)

For the sake of time lets use a cached version of the data I acquired yesterday.

df_all <- read_rda("data/phase_iii.rda")

Lets look at the data

glimpse(df_all)

Rows: 58,839 Columns: 51 $ code_research “SR3”, “SR3”, “SR3”, “SR3”, “SR3”, “S… $ id_contract ”MSFC0199208DNAS839394“,”MSFC0199305… $ date_obligation 1992-07-29, 1993-05-24, 1996-08-22, … $ id_contract_analysis “MSFC0199208DNAS839394”, “MSFC0199305… $ type_procurement ”AWARD“,”AWARD“,”AWARD“,”AWARD“,”… $ id_contract_idv NA, NA, NA, NA, NA, NA, NA, “N0017498… $ code_modification ”0“,”0“,”0“,”1“,”0“,”1“,”1“,”0… $ number_transaction 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0… $ type_award “DCA DEFINITIVE CONTRACT”, “DCA DEFIN… $ amount_obligation 1281447, 558195, 598535, 0, 1320000, … $ id_agency_award ”8000“,”8000“,”8000“,”8000“,”8000… $ name_agency_award “NATIONAL AERONAUTICS AND SPACE ADMIN… $ name_office_award ”MARSHALL SPACE FLIGHT CENTER“,”MARS… $ type_product_or_service “S”, “S”, “S”, “S”, “S”, “S”, “S”, “S… $ code_product_service ”AR91“,”C211“,”AR22“,”AR22“,”M182… $ id_naics NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ name_naics NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ id_duns 54910716, 153869896, 621970383, 62197… $ name_vendor “APPLIED RESEARCH INC”, “MAYFLOWER CO… $ city_vendor ”HUNTSVILLE“,”BURLINGTON“,”GREENVIL… $ code_state_vendor “AL”, “MA”, “IN”, “IN”, “AL”, “AL”, “… $ zipcode_vendor ”35806“,”01803“,”47124“,”47124“,”… $ id_duns_parent 54910716, 153869896, 621970383, 62197… $ name_vendor_parent “APPLIED RESEARCH INC”, “MAYFLOWER CO… $ url_csv ”https://www.fpds.gov/ezsearch/fpdspo… $ year_fiscal_obligation 1992, 1993, 1996, 1996, 1997, 1997, 1… $ has_duns_parent TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, T… $ is_missing_duns FALSE, FALSE, FALSE, FALSE, FALSE, FA… $ id_department_award “8000”, “8000”, “8000”, “8000”, “8000… $ name_department_award ”NATIONAL AERONAUTICS AND SPACE ADMIN… $ code_department_award 80, 80, 80, 80, 80, 80, 80, 97, 97, 8… $ type_contract_id_analysis “CONTRACT”, “CONTRACT”, “CONTRACT”, “… $ id_cgac_award 80, 80, 80, 80, 80, 80, 80, 17, 17, 8… $ name_agency_cgac_award ”NATIONAL AERONAUTICS AND SPACE ADMIN… $ slug_cgac_award “080”, “080”, “080”, “080”, “080”, “0… $ type_psc ”SERVICE“,”SERVICE“,”SERVICE“,”SER… $ name_product_service “R&D- SPACE: OTHER”, “ARCHITECT AND E… $ id_solicitation_group ”A“,”C“,”A“,”A“,”M“,”M“,”C“,”A… $ name_solicitation_group “RESEARCH AND DEVELOPMENT”, “ARCHITEC… $ has_parent FALSE, FALSE, FALSE, FALSE, FALSE, FA… $ is_idv FALSE, FALSE, FALSE, FALSE, FALSE, FA… $ code_additional_reporting NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ description_additonal_reporting NA, NA, NA, NA, NA, NA, NA, NA, NA, N… $ date_solicitation NA, NA, NA, NA, NA, NA, NA, NA, NA, … $ year_budget 1992, 1993, 1996, 1997, 1997, 1998, 1… $ names_vendor_listed ”APPLIED RESEARCH INC“,”MAYFLOWER CO… $ count_vendors_listed 1, 3, 2, 2, 4, 4, 3, 2, 2, 2, 1, 1, 2… $ has_multiple_vendors FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, … $ names_vendor_parent_listed “APPLIED RESEARCH INC”, "MAYFLOWER CO… $ count_vendors_parent_listed 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1… $ has_multiple_parent_vendors FALSE, FALSE, FALSE, FALSE, FALSE, FA…

skim(df_all)

Variable type: character

Variable type: Date

Variable type: logical

Variable type: numeric

Phase III Cumulative Spend

First thing to look at is the cumulative spend.

tbl_cumulative_sbir <-
  df_all %>%
  count(date_obligation, wt = amount_obligation, name = "amount") %>%
  mutate(amount_cumulative = cumsum(amount))

Next lets visualize it in an area chart.

gg_cumulative_spend <-
  tbl_cumulative_sbir %>%
  ggplot(aes(x = date_obligation, y = amount_cumulative)) +
  theme_minimal() +
  geom_line(color = "#00B0F0", size = .5) +
  geom_area(fill = "#00B0F0",
            alpha = 0.25,
            color = NA) +
  theme(
    panel.background = element_rect(fill = "#fffff8", color = NA),
    plot.background = element_rect(fill = "#fffff8", color = NA)
  ) +
  labs(
    x = NULL,
    y = "$ Obligated",
    title = "Cumulative Phase III STTR/SBIR Obligations",
    subtitle = "",
    caption = ""
  ) +
  scale_x_date(expand = c(0, 0),
               breaks = scales::pretty_breaks(n = 10)) +
  hrbrthemes::theme_ipsum_rc(
    grid = "XY",
    plot_title_size = 10,
    subtitle_size = 8.5,
    caption_size = 8.5,
    axis_text_size = 10,
    axis_title_size = 10,
    strip_text_size = 10
  ) +
  geom_smooth(
    colour = "#000000",
    method = 'loess',
    span = .3,
    size = .5,
    alpha = 0.45
  ) +
  geom_smooth(
    colour = "red",
    method = 'lm',
    size = .5,
    alpha = 0.45
  ) +
  scale_y_continuous(labels = scales::dollar,
                     breaks = scales::pretty_breaks(n = 10))

gg_cumulative_spend

R is a functional programming language. Lets take advantage of this by turning this area visualization code into a function that we will use later for something very cool.

plot_gg_cumulative_area <-
  function(data,
           plot_title = "",
           use_lm = T,
           use_loess = T)  {
    gg <- data %>%
      ggplot(aes(x = date_obligation, y = amount_cumulative)) +
      theme_minimal() +
      geom_line(color = "#00B0F0", size = .5) +
      geom_area(fill = "#00B0F0",
                alpha = 0.25,
                color = NA) +
      theme(
        panel.background = element_rect(fill = "#fffff8", color = NA),
        plot.background = element_rect(fill = "#fffff8", color = NA)
      ) +
      labs(
        x = NULL,
        y = "$ Obligated",
        title = plot_title,
        subtitle = "",
        caption = ""
      ) +
      scale_x_date(expand = c(0, 0),
                   breaks = scales::pretty_breaks(n = 10)) +
      hrbrthemes::theme_ipsum_rc(
        grid = "XY",
        plot_title_size = 7,
        subtitle_size = 6.5,
        caption_size = 6.5,
        axis_text_size = 7,
        axis_title_size = 7,
        strip_text_size = 7
      ) +
      scale_y_continuous(labels = scales::dollar,
                         breaks = scales::pretty_breaks(n = 10))
    
    if (use_loess) {
      gg <- gg  +
        geom_smooth(
          colour = "#000000",
          method = 'loess',
          span = .3,
          size = .5,
          alpha = 0.45
        )
    }
    
    if (use_lm) {
      gg <- gg +
        geom_smooth(
          colour = "red",
          method = 'lm',
          size = .5,
          alpha = 0.45
        )
    }
    
    gg
    
  }

Lets make sure the function worked

plot_gg_cumulative_area(
  data = tbl_cumulative_sbir,
  plot_title = "Does this work?",
  use_lm = T,
  use_loess = T
)

It worked.

Phase III Annual Spend by Type

Now lets look at the spend over time by year by SBIR/STTR type.

tbl_year <- df_all %>%
  group_by(code_research, year_fiscal_obligation) %>%
  summarise(amount = sum(amount_obligation),
            .groups = "drop")

tbl_year %>%
  munge_data() %>%
  arrange(year_fiscal_obligation) %>%
  gt()

Now we can visualize it.

hc_bar_year <- hchart(tbl_year,
                      "column",
                      hcaes(x = year_fiscal_obligation,
                            y = amount,
                            group = code_research)) %>%
  hc_add_theme(hc_theme_elementary())  %>%
  hc_title(text = "SBIR/STTR Phase III Awards by Year") %>% 
  hc_plotOptions(series = list(stacking = "normal"))

hc_bar_year

Phase III Department Spend Stream Graph

Next lets take a look at department spend over time.

Again we are going to want to lump a bunch of the low frequency agencies together.

We also will limit this analysis for SBIR/STTRs since 2000

tbl_by_dept <-
  df_all %>%
  count(year_budget,
        name_department_award,
        wt = amount_obligation,
        name = "amount") %>%
  filter(amount > 0, year_budget >= 2000) %>%
  mutate(
    department_group = fct_lump(
      name_department_award,
      n = 5,
      w = amount,
      other_level = "ALL OTHER DEPARTMENTS"
    )
  ) %>%
  count(year_budget, department_group, wt = amount, name = "amount") %>%
  mutate(department_group = fct_reorder(department_group, -amount))

Now we can build an interactive streamgraph with this information.

hc_dept_stream_graph <-
  tbl_by_dept %>%
  hchart("streamgraph",
         hcaes(year_budget, amount, group = department_group)) %>%
  hc_yAxis(visible = T,
           startOnTick = FALSE,
           endOnTick = FALSE) %>%
  hc_title(text = "SBIR Phase III by Department")

hc_dept_stream_graph

Exploring SBIR/STTR Phase III Award by Agency

Lets explore this data by agency.

First lets see the raw breakdown by agency.

tbl_agency_amt <-
  df_all %>%
  filter(!is.na(name_agency_cgac_award)) %>%
  count(name_agency_cgac_award,
        wt = amount_obligation,
        name = "amount",
        sort = T)

tbl_agency_amt %>%
  munge_data() %>%
  gt()

Next lets lump together low frequency agencies and visualize this data.

gg_agency <-
  tbl_agency_amt %>%
  mutate(
    agency_group = fct_lump(
      name_agency_cgac_award,
      n = 15,
      w = amount,
      other_level = "ALL OTHER AGENCIES"
    )
  ) %>%
  count(agency_group,
        wt = amount,
        sort = T,
        name = "amount") %>%
  mutate(agency_group = fct_reorder(agency_group, amount)) %>%
  ggplot(aes(x = agency_group, y = amount)) +
  geom_bar(
    stat = "identity",
    fill = "#f68060",
    alpha = .6,
    width = .4
  ) +
  coord_flip() +
  xlab("") +
  scale_y_continuous(labels = scales::dollar, n.breaks = 5) +
  geom_text(
    aes(label = round(amount / 1000000, digits = 2)),
    position = position_dodge(width = 0.9),
    vjust = -0.25,
    check_overlap = T
  ) +
  ggtitle("Top SBIR/STTR Phase III Awarding Agencies") +
  labs(subtitle = "By Lumped Government-wide Accounting Agency [CGAC] - Top 15",
       x = "") +
  theme_ipsum()

gg_agency

Lets make this look better

gg_agency <-
  gg_agency +
  theme(
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_blank(),
    legend.position = "none",
    text = element_text(size = 8,  family = "serif")
  ) +
  scale_y_sqrt(labels = scales::dollar, n.breaks = 4)

gg_agency

Explore Every SBIR/STTR Awarding Office

Lets take a look at all the awarding offices of SBIR Phase III and put it into an interactive table.

tbl_office <-
  df_all %>%
  filter(!is.na(name_office_award)) %>%
  group_by(name_department_award,
           name_agency_cgac_award,
           name_office_award) %>%
  summarise(
    date_first = min(date_obligation, na.rm = T),
    date_recent = max(date_obligation, na.rm = T),
    distinct_vendors = n_distinct(id_duns, na.rm = T),
    amount = sum(amount_obligation, na.rm = T),
    amount_mean = mean(amount_obligation),
    actions = n(),
    contracts = n_distinct(id_contract_analysis, na.rm = T),
    .groups = "drop"
  ) %>%
  filter(amount > 0) %>%
  arrange(desc(amount))

table_office <- tbl_office %>%
  reactable(
    filterable = F,
    resizable = T,
    searchable = T,
    showPageSizeOptions = T,
    pageSizeOptions = c(5, 10, 20),
    sortable = T,
    compact = T,
    columns = list(
      date_first = colDef(name = "First Award"),
      date_recent = colDef(name = "Recent Award"),
      name_department_award = colDef(
        name = "Department",
        sortable = T,
        filterable = T
      ),
      name_agency_cgac_award = colDef(
        name = "Agency",
        sortable = T,
        filterable = T
      ),
      name_office_award = colDef(
        name = "Office",
        sortable = T,
        filterable = T
      ),
      distinct_vendors = colDef(name = "Unique Vendors"),
      amount = colDef(
        name = "$ Total",
        format = colFormat(
          prefix = "$",
          separators = TRUE,
          digits = 0
        )
      ),
      amount_mean = colDef(
        name = "$ Mean",
        format = colFormat(
          prefix = "$",
          separators = TRUE,
          digits = 0
        )
      ),
      contracts = colDef(name = "Unique Contracts"),
      actions = colDef(name = "Contract Actions")
    )
  )

table_office

First Time Phase III Vendor Analysis.

First thing is to build a table that shows us first time vendors. We have to exclude 1 special DUNS number, inquisitive minds should feel free to explore it on their own time.

tbl_first <-
  df_all %>%
  filter(id_duns != 123456787) %>%
  group_by(id_duns) %>%
  filter(date_obligation == min(date_obligation)) %>%
  filter(amount_obligation > 0) %>%
  slice(1) %>%
  ungroup() %>%
  select(
    id_duns,
    year_budget_first = year_budget,
    date_first_phase_3 = date_obligation,
    id_contract_analysis_first = id_contract_analysis,
    department_first = name_department_award,
    agency_first = name_agency_cgac_award,
    office_first = name_office_award
  ) %>%
  arrange(desc(year_budget_first))

This gives us information on 2,450 Phase III awardees.

Now lets look at the raw counts over time between fisca year 1998 and 2020.

gg_first_time <- 
  tbl_first %>%
  count(year_budget_first) %>%
  filter(year_budget_first >= 1998, year_budget_first <= 2020) %>%
  ggplot(aes(year_budget_first, n)) +
  geom_line() +
  theme_ipsum() +
  labs(title = "New Phase III SBIR/STTR Recipients",
       x = "Budget Year",
       y = "Count")

gg_first_time

Agency Attribution of New Phase III Companies

Next lets take it a step further and take a look at an attribution by year of which agencies were responsible for the new vendors.

colors <-
  c("#00008BFF",
    "#1EFAA0FF",
    "#00FA00FF",
    "#ADFF2FFF",
    "#FA7D00FF",
    "#78005AFF")

hc_attribution <- 
  tbl_first %>%
  count(year_budget_first, agency_first) %>%
  filter(year_budget_first >= 1998, year_budget_first <= 2020) %>%
  mutate(agency_lumped = fct_lump(agency_first, n = 5, other_level = "ALL OTHER AGENCIES")) %>%
  count(year_budget_first, agency_lumped, wt = n) %>%
  mutate(agency_lumped = fct_reorder(agency_lumped, n)) %>%
  filter(!is.na(agency_lumped)) %>%
  hchart(
    "column",
    hcaes(year_budget_first, n, group = agency_lumped),
    stacking = "percent",
    borderWidth = 0,
    groupPadding = 0,
    pointPadding  = 0,
  ) %>%
  hc_colors(colors) %>%
  hc_add_theme(hc_theme_538()) %>%
  hc_xAxis(gridLineWidth = 0,
           title = list(text = NULL)) %>%
  hc_tooltip(
    table = TRUE,
    outside = TRUE,
    shared = TRUE,
    useHTML = TRUE,
    headerFormat = "<small>{point.key}</small><table>",
    pointFormat = str_c(
      "<tr><td style=\"color: {series.color}\">{series.name}: </td>",
      "<td style=\"text-align: right\"><b>{point.y:0.f}</b></td>"
    ),
    footerFormat = "<tr><td><b>Total</b>: </td><td style=\"text-align: right\"><b>{point.total:0.f}</b></td></tr></table>",
    style = list(fontSize = "0.7em")
  ) %>%
  hc_legend(
    verticalAlign = "top",
    align = "left",
    itemStyle =  list(fontWeight = 500)
  ) %>%
  hc_title(text = "Share of New Phase III Awardees by Agency Group") %>%
  hc_plotOptions(series = list(
    marker = list(
      radius = 0,
      enabled = FALSE,
      symbol = "circle"
    ),
    states = list(hover = list(halo = list(size = 0)))
  )) %>%
  hc_yAxis(title = list(text = "Share of New Vendors"),
           type = "percent")

hc_attribution

Deep Dive: Phase III Awardee Exploration Trelliscope

Now lets dig into the Phase III awardees and build an interactive trelliscope to explore the data!

First step is to build a vendor summary data frame

tbl_vendors <-
  df_all %>%
  filter(!is.na(id_duns)) %>%
  group_by(id_duns) %>%
  summarise(
    vendor = name_vendor[which.max(amount_obligation)],
    date_first = min(date_obligation, na.rm = T),
    date_recent = max(date_obligation, na.rm = T),
    count_types = n_distinct(code_research, na.rm = T),
    count_agencies = n_distinct(id_cgac_award, na.rm = T),
    count_departments = n_distinct(id_department_award),
    count_offices = n_distinct(name_office_award, na.rm = T),
    amount = sum(amount_obligation, na.rm = T),
    amount_mean = mean(amount_obligation),
    actions = n(),
    contracts = n_distinct(id_contract_analysis, na.rm = T),
    .groups = "drop"
  ) %>%
  filter(amount > 0) %>%
  arrange(desc(amount)) %>%
  mutate(
    year_recent = year(date_recent),
    year_first = year(date_first),
    .before = "date_first"
  )

Here are the top 10

tbl_vendors %>%
  slice(1:10) %>%
  munge_data() %>%
  gt()

Ahh there is that interesting DUNS number again. Lets get rid of it.

tbl_vendors <-
  tbl_vendors %>%
  filter(id_duns != 123456787)

Lets explore the data interactively [this will not work in the rendered markdown]

esquisse::esquisser(tbl_vendors)

Lets filter out some of the the small awardees by ensuring the companies have at-least 2 contracts and over $500,000 in awards

tbl_vendors <-
  tbl_vendors %>%
  filter(contracts >= 2, amount >= 500000)

Lets try to figure out how many clusters there are.

mplot3.xy(
  log(tbl_vendors$actions),
  log(tbl_vendors$amount / 1000000),
  cluster = "PAM",
  cluster.params = list(k = 10),
  main = "Phase III $ by Actions",
  fit = "lm",
  xlab = "Contract Actions",
  ylab = "Contract $ (millions)",
  theme = "white"
)

10 looks good.

Next we can add the cluster to our summary data.

clusters <- 
  tbl_vendors %>% select(-id_duns) %>%
  select_if(is.numeric) %>%
  rtemis::u.PAM(k = 10)

[2020-11-05 16:17:42 rtemis::u.PAM] Hello, alexbresler [2020-11-05 16:17:43 rtemis::u.PAM] Partitioning Around Medoids with k = 10… C pam(): computing 228151 dissimilarities from 676 x 10 matrix: [Ok] pam()’s bswap(*, s=1.05479e+09, pamonce=0): build 10 medoids: new repr. 338 new repr. 9 new repr. 53 new repr. 2 new repr. 129 new repr. 21 new repr. 545 new repr. 217 new repr. 15 new repr. 4 after build: medoids are 2 4 9 15 21 53 129 217 338 545 and min.dist dysma[1:n] are 1.24e+08 0 2.31e+08 0 1.9e+07 1.11e+07 6.9e+06 1.17e+06 0 3.32e+07 4.15e+07 3.3e+07 2.11e+07 2.04e+07 0 1.99e+06 2.11e+07 2.06e+07 1.72e+07 1.27e+07 0 3.6e+06 8.29e+06 1.02e+07 1.32e+07 1.74e+07 2.63e+07 2.7e+07 3.6e+07 3.61e+07 3.16e+07 3.02e+07 2.95e+07 2.92e+07 2.03e+07 1.82e+07 1.68e+07 1.58e+07 1.58e+07 1.42e+07 1.19e+07 1.11e+07 1.01e+07 9.5e+06 9.28e+06 8.8e+06 8.32e+06 7.68e+06 3.33e+06 1.62e+06 1.02e+06 2.7e+05 0 6.51e+05 1.17e+06 1.21e+06 1.51e+06 2.89e+06 3.66e+06 4.09e+06 5.78e+06 7.74e+06 8.54e+06 9.28e+06 1.07e+07 1.08e+07 1.13e+07 1.16e+07 1.21e+07 1.47e+07 1.52e+07 1.5e+07 1.49e+07 1.41e+07 1.31e+07 1.19e+07 1.09e+07 1.07e+07 1.02e+07 9.58e+06 9.57e+06 9.43e+06 9.35e+06 9.13e+06 9.02e+06 8.95e+06 8.86e+06 8.16e+06 7.21e+06 6.8e+06 6.46e+06 6.37e+06 6.06e+06 5.71e+06 5.67e+06 5.04e+06 4.91e+06 4.64e+06 4.6e+06 4.33e+06 4.71e+06 4.03e+06 3.99e+06 3.28e+06 3.24e+06 3.06e+06 2.85e+06 2.48e+06 2.34e+06 2.31e+06 2.28e+06 2.24e+06 2.19e+06 1.96e+06 1.74e+06 1.77e+06 1.62e+06 1.55e+06 1.29e+06 1.11e+06 1.06e+06 9.78e+05 9.51e+05 9.93e+05 8.31e+05 6.99e+05 6.49e+05 2.93e+05 0 6.22e+05 6.67e+05 1.12e+06 1.14e+06 1.14e+06 1.53e+06 1.59e+06 1.6e+06 1.83e+06 1.97e+06 2.22e+06 2.32e+06 2.4e+06 2.61e+06 2.82e+06 2.93e+06 3.28e+06 3.19e+06 3.32e+06 3.34e+06 3.42e+06 3.48e+06 3.59e+06 3.83e+06 4.02e+06 4.82e+06 4.26e+06 4.57e+06 4.6e+06 4.8e+06 4.94e+06 5.16e+06 5.18e+06 5.31e+06 5.33e+06 5.55e+06 5.61e+06 5.62e+06 5.53e+06 5.49e+06 5.48e+06 5.31e+06 5.14e+06 4.94e+06 4.65e+06 4.38e+06 4.2e+06 4.22e+06 4.18e+06 4.03e+06 3.9e+06 3.58e+06 3.98e+06 3.32e+06 3.23e+06 3.74e+06 2.84e+06 2.74e+06 2.69e+06 3.99e+06 2.64e+06 2.55e+06 4.78e+06 2.48e+06 2.34e+06 2.05e+06 1.4e+06 3.95e+06 1.36e+06 1.2e+06 1.15e+06 1.09e+06 1.05e+06 9.79e+05 9.79e+05 9.35e+05 9.36e+05 1.25e+06 6.99e+05 8.17e+05 6.07e+05 5.7e+05 7.9e+05 4.67e+05 3.53e+05 1.33e+05 4.08e+05 0 2.49e+05 1.77e+06 3.91e+05 1.45e+05 4.57e+05 1.75e+06 5.18e+05 5.7e+05 5.42e+05 1.21e+06 6.47e+05 7.16e+05 7.43e+05 7.63e+05 8.42e+05 9.26e+05 9.4e+05 9.92e+05 1.13e+06 1.09e+06 1.37e+06 1.19e+06 3.07e+06 1.23e+06 1.21e+06 1.29e+06 1.34e+06 1.37e+06 1.8e+06 1.52e+06 1.52e+06 1.58e+06 1.56e+06 1.59e+06 1.6e+06 1.64e+06 1.66e+06 2.01e+06 1.81e+06 1.84e+06 1.9e+06 2.02e+06 2.05e+06 2.22e+06 2.31e+06 2.53e+06 2.42e+06 2.44e+06 2.46e+06 2.45e+06 2.58e+06 2.76e+06 2.68e+06 2.7e+06 2.83e+06 2.67e+06 2.66e+06 2.62e+06 2.54e+06 2.5e+06 2.5e+06 2.46e+06 2.53e+06 2.37e+06 2.3e+06 2.33e+06 2.21e+06 2.1e+06 2.11e+06 2.06e+06 1.96e+06 1.95e+06 1.92e+06 1.91e+06 1.77e+06 1.7e+06 1.61e+06 1.6e+06 1.6e+06 1.62e+06 1.53e+06 2.44e+06 1.53e+06 1.52e+06 1.52e+06 1.42e+06 1.44e+06 1.32e+06 1.57e+06 1.14e+06 1.12e+06 1.08e+06 1.06e+06 9.14e+05 8.55e+05 1.44e+06 2.77e+06 7.74e+05 6.87e+05 6.56e+05 7.07e+05 8.63e+05 7.52e+05 5.14e+05 4.9e+05 5.27e+05 4.56e+05 4.53e+05 8.65e+05 5.75e+05 4.85e+05 3.39e+05 3.4e+05 4.05e+05 2.86e+05 2.27e+05 2.19e+05 2.9e+05 1.73e+05 3.16e+05 0 2.3e+05 1.35e+05 2.27e+05 1.05e+05 2.34e+05 2.05e+05 2.13e+05 1.69e+05 2.51e+05 2.07e+05 3.63e+05 3.75e+05 4.22e+05 3.78e+05 4.64e+05 5.25e+05 4.9e+05 5.34e+05 7.07e+05 6.31e+05 6.03e+05 1.34e+06 6.74e+05 7.43e+05 7.23e+05 7.57e+05 7.97e+05 7.92e+05 8.02e+05 8.82e+05 9.12e+05 9.27e+05 9.24e+05 9.57e+05 9.74e+05 1.02e+06 1.24e+06 1.05e+06 1.11e+06 1.15e+06 1.14e+06 1.2e+06 1.21e+06 1.24e+06 2.06e+06 1.27e+06 1.3e+06 1.31e+06 1.33e+06 1.43e+06 1.45e+06 1.49e+06 1.71e+06 1.51e+06 1.51e+06 1.54e+06 1.54e+06 1.58e+06 1.57e+06 1.68e+06 1.7e+06 1.7e+06 1.73e+06 1.73e+06 1.77e+06 1.78e+06 1.8e+06 1.8e+06 1.84e+06 1.83e+06 1.84e+06 1.83e+06 1.83e+06 1.77e+06 1.98e+06 1.76e+06 1.71e+06 1.7e+06 1.69e+06 1.77e+06 1.66e+06 1.65e+06 1.64e+06 1.63e+06 1.66e+06 1.62e+06 1.61e+06 1.6e+06 1.61e+06 1.6e+06 2.07e+06 1.58e+06 1.64e+06 1.51e+06 1.5e+06 1.49e+06 1.47e+06 1.42e+06 1.4e+06 1.36e+06 1.35e+06 1.38e+06 1.32e+06 1.33e+06 1.37e+06 1.27e+06 1.25e+06 1.25e+06 1.21e+06 1.26e+06 1.21e+06 1.24e+06 1.19e+06 1.21e+06 1.19e+06 1.17e+06 1.13e+06 1.15e+06 1.07e+06 1.03e+06 1.03e+06 9.85e+05 9.61e+05 9.52e+05 9.09e+05 8.91e+05 9.12e+05 8.75e+05 8.65e+05 8.54e+05 8.26e+05 8.29e+05 8.15e+05 8.03e+05 7.92e+05 7.64e+05 8.42e+05 7.49e+05 7.45e+05 7.46e+05 7.37e+05 7.11e+05 6.98e+05 6.96e+05 7.22e+05 6.73e+05 6.36e+05 6.3e+05 6.38e+05 6.1e+05 6.12e+05 6.08e+05 6.04e+05 6.03e+05 6.25e+05 6.19e+05 5.73e+05 5.62e+05 5.63e+05 5.67e+05 5.55e+05 5.55e+05 5.39e+05 5.21e+05 5.17e+05 4.98e+05 4.97e+05 5e+05 4.7e+05 4.62e+05 4.59e+05 4.46e+05 4.46e+05 6.09e+05 4.64e+05 3.73e+05 3.62e+05 3.53e+05 3.48e+05 3.49e+05 3.41e+05 3.26e+05 3.23e+05 2.79e+05 4.73e+05 2.66e+05 2.41e+05 2.35e+05 2.5e+05 2.42e+05 2.01e+05 1.82e+05 1.75e+05 2.14e+05 1.61e+05 1.3e+05 1.76e+05 6.24e+05 1.09e+05 8.92e+04 2.08e+05 1.96e+05 4.5e+04 7.46e+04 2.98e+04 7.94e+04 0 6.21e+04 1.11e+05 2.46e+04 1.45e+05 5.61e+04 1.2e+05 8.65e+04 6.74e+04 7.73e+04 7.31e+04 1.17e+05 1.12e+05 9.43e+04 1.84e+05 1.42e+05 1.89e+05 1.15e+05 1.15e+05 1.89e+05 1.44e+05 1.78e+05 1.59e+05 1.64e+05 1.64e+05 1.78e+05 1.87e+05 2.05e+05 2.1e+05 2.44e+05 4.99e+05 2.19e+05 2.26e+05 2.29e+05 2.55e+05 3.3e+05 2.61e+05 2.58e+05 2.72e+05 2.86e+05 2.97e+05 3e+05 3.09e+05 3.36e+05 5.22e+05 4.05e+05 4.02e+05 4.05e+05 4.19e+05 4.62e+05 5.56e+05 4.5e+05 4.64e+05 4.84e+05 4.76e+05 4.68e+05 4.89e+05 4.94e+05 4.84e+05 5.08e+05 5.03e+05 5.27e+05 5.18e+05 5.31e+05 5.37e+05 5.43e+05 5.46e+05 5.69e+05 5.58e+05 5.66e+05 5.87e+05 6.03e+05 6.1e+05 6.19e+05 6.12e+05 6.29e+05 6.27e+05 6.26e+05 6.43e+05 6.52e+05 6.74e+05 6.81e+05 6.81e+05 6.91e+05 7.03e+05 7.35e+05 7.23e+05 7.22e+05 7.23e+05 7.43e+05 7.39e+05 7.4e+05 7.55e+05 7.71e+05 7.68e+05 7.73e+05 7.66e+05 8.12e+05 7.99e+05 8.19e+05 8.3e+05 8.27e+05 8.24e+05 8.3e+05 8.37e+05 8.36e+05 8.36e+05 8.59e+05 8.64e+05 8.61e+05 8.73e+05 8.87e+05 9.07e+05 8.95e+05 9.01e+05 9.14e+05 9.15e+05 9.13e+05 9.29e+05 9.3e+05 9.44e+05 9.49e+05 9.6e+05 9.51e+05 9.64e+05 9.63e+05 9.64e+05 9.72e+05 9.71e+05 9.7e+05 9.78e+05 9.84e+05 swp new 26 <-> 21 old; decreasing diss. 2.23105e+09 by -3.38117e+07 swp new 115 <-> 129 old; decreasing diss. 2.19724e+09 by -2.21283e+07 swp new 210 <-> 217 old; decreasing diss. 2.17511e+09 by -724555 swp new 111 <-> 115 old; decreasing diss. 2.17439e+09 by -119224 swp new 8 <-> 9 old; decreasing diss. 2.17427e+09 by -8711.59 end{bswap()}, end{cstat()}

[2020-11-05 16:17:43 rtemis::u.PAM] Run completed in 0.01 minutes (Real: 0.50; User: 0.48; System: 2e-03)

tbl_vendors <-
  tbl_vendors %>%
  mutate(pam_cluster = as.character(clusters$clusters.train),
         .before = "id_duns")

Now we can build the trelliscope. We need to build a nested table with the cumulative awards for each of the Phase III awardees.

tbl_cumulative <-
  df_all %>%
  filter(id_duns %in% c(tbl_vendors$id_duns)) %>%
  group_by(id_duns, date_obligation) %>%
  summarise(amount = sum(amount_obligation)) %>%
  mutate(amount_cumulative = cumsum(amount)) %>%
  ungroup() %>%
  group_by(id_duns) %>%
  nest() %>%
  ungroup()

Lets see if it worked

tbl_cumulative$data[[7]] %>% plot_gg_cumulative_area(plot_title = "Test")

Now we can build the trelliscope using the function we built to plot the cumulative area for each of the companies. We also want to join in all the features we want to explore [this also won’t render in the final version of the markdown]

tbl_trelliscope_data <-
  tbl_vendors %>%
  left_join(tbl_cumulative, by = "id_duns") %>%
  left_join(tbl_first %>% select(id_duns, department_first, agency_first, office_first),
            by = "id_duns") %>%
  mutate_at(c("year_recent", "year_first"), as.character)

trell_sample <- tbl_trelliscope_data %>%
  sample_n(10) %>%
  mutate(amount = round(amount / 1000000, digits = 2),
         panel = map_plot(data,
                          function(data) {
                            plot_gg_cumulative_area(
                              data = data,
                              plot_title = "Cumulative Phase IIIs",
                              use_lm = T,
                              use_loess = T
                            )
                          })) %>%
  arrange(desc(amount)) %>%
  trelliscope(
    name = "Phase III Cumulative Awardee Trelliscope",
    desc = "Minimum of 2 Phase III contracts",
    nrow = 1,
    ncol = 2,
    width = 500,
    height = 500,
    state = list(
      labels = c(
        "vendor",
        "amount",
        "contracts",
        'date_first',
        "date_recent",
        "pam_cluster",
        "department_first",
        "agency_first",
        "office_first"
      ),
      sort_spec(name = "amount", dir = "desc")
    )
  )

trell_sample

Looks good, now lets build the full trelliscope.

phase_3_trelliscope <-
  tbl_trelliscope_data %>%
  mutate(amount = round(amount / 1000000, digits = 2),
         panel = map_plot(data,
                          function(data) {
                            plot_gg_cumulative_area(
                              data = data,
                              plot_title = "Cumulative Phase IIIs",
                              use_lm = T,
                              use_loess = T
                            )
                          })) %>%
  arrange(desc(amount)) %>%
  trelliscope(
    name = "Phase III Cumulative Awardee Trelliscope",
    desc = "Minimum of 2 Phase III contracts",
    nrow = 1,
    ncol = 2,
    width = 500,
    height = 500,
    state = list(
      labels = c(
        "vendor",
        "amount",
        "contracts",
        'date_first',
        "date_recent",
        "pam_cluster",
        "department_first",
        "agency_first",
        "office_first"
      ),
      sort_spec(name = "amount", dir = "desc")
    )
  )

phase_3_trelliscope

AFWERX Portfolio Data

First lets bring in the data

df_afwerx <- sbir_afwerx_portfolio(use_cached = T)

Now lets look at the data

df_afwerx %>% glimpse()

Rows: 1,759 Columns: 51 $ date_updated 2020-10-31, 202… $ id 1, 2, 3, 4, 5, 6… $ id_phase “PHASE I”, “PHAS… $ type_solicitation ”OPEN TOPIC“,”O… $ name_solicitation “AETC OPEN TOPIC… $ group_solicitation ”AF191-004“,”AF… $ id_office “AF191”, “AF191”… $ id_cohort “004”, “004”, “0… $ id_program ”SBIR“,”SBIR“, … $ is_open_topic_awardee TRUE, TRUE, TRUE… $ name_company_clean ”BRANCH TECHNOLO… $ name_company “BRANCH TECHNOLO… $ url_company ”https://www.bra… $ slug_soundex_company “B652325420000”,… $ keyword_afwerx “AUTONOMOUS ROBO… $ keyword_company_clean_afwerx ”AUTONOMOUS SYST… $ group_topic “AF191”, “AF191”… $ name_company_legal_clean “BRANCH TECHNOLO… $ id_duns 79377382, 799165… $ slug_cage ”74NH7“,”7WUZ2“… $ date_registration_initial 2014-05-01, 201… $ date_expiration 2021-04-15, 202… $ date_last_update 2020-04-15, 202… $ date_activation 2020-04-15, 202… $ name_company_legal ”BRANCH TECHNOLO… $ name_company_dbasam “BRANCH TECHNOLO… $ name_company_division NA, NA, NA, NA, … $ date_company_start 2014-04-15, 201… $ url_company_sam ”https://www.bra… $ email_point_of_contact_electronic_business “david.goodloe@b… $ url_point_of_contact ”https://branch.… $ email_point_of_contact_electronic_business_alternate “platt@branch.te… $ location_company ”1530 RIVERSIDE … $ name_company_sam “BRANCH TECHNOLO… $ has_duns TRUE, TRUE, TRUE… $ id_naics_primary 236220, 541714, … $ name_naics_primary ”COMMERCIAL AND … $ name_industry_group_naics "RESIDENTIAL BUI… $ count_naics 6, 3, 3, 1, 1, 1… $ count_naics_exceptions 0, 1, 2, 0, 0, 0… $ is_primary_naics FALSE, FALSE, FA… $ has_naics TRUE, TRUE, TRUE… $ count_product_service_codes NA, NA, 10, 1, N… $ has_product_service_codes TRUE, TRUE, TRUE… $ count_business_types 2, 1, 3, 3, 2, 5… $ has_business_types TRUE, TRUE, TRUE… $ has_sba_types TRUE, TRUE, TRUE… $ date_sam_data 2020-10-04, 202… $ data_psc [NULL, NULL, <t… $ data_naics [<tbl_df[4 x 3]… $ data_business_types [<tbl_df[4 x 2]…

df_afwerx %>% skim()

Variable type: character

Variable type: Date

Variable type: list

Variable type: logical

Variable type: numeric

AFWERX Counts

Lets look at some quick counts:

First by phase:

df_afwerx %>%
  count(id_program, id_phase, sort = T) %>% 
  gt()

Next by solicitation type:

df_afwerx %>%
  count(id_phase, type_solicitation, sort = T) %>% 
  gt()

Next by solicitation:

df_afwerx %>%
  count(
    id_phase,
    id_program,
    type_solicitation,
    group_solicitation,
    name_solicitation,
    sort = T
  ) %>% 
  gt()

AFWERX Company Keyword Analysis

Now lets explore some of the keywords.

tbl_company_keywords <- df_afwerx %>%
  select(
    id_phase,
    id_program,
    type_solicitation,
    group_solicitation,
    name_solicitation,
    name_company_clean,
    keyword_company_clean_afwerx
  ) %>%
  separate_rows(keyword_company_clean_afwerx, sep = "\\|") %>%
  mutate_all(str_squish)

Now lets count the keywords

tbl_af_keywords <- 
  tbl_company_keywords %>%
  mutate_all(str_squish) %>%
  count(keyword_company_clean_afwerx, sort = T)

Here are all the keywords and their count

af_keywords <- reactable(tbl_af_keywords, filterable = T, searchable = T)

af_keywords

Now lets explore the top 50 keywords.

gg_top_50 <- 
  tbl_af_keywords %>%
  slice(1:50) %>%
  mutate(keyword_company_clean_afwerx = fct_reorder(keyword_company_clean_afwerx, n)) %>% 
  ggplot(aes(x = keyword_company_clean_afwerx, y = n)) +
  geom_bar(
    stat = "identity",
    fill = "#f68060",
    alpha = .6,
    width = .4
  ) +
  coord_flip() +
  xlab("") +
  theme_bw() +
  scale_y_log10() +
  geom_text(aes(label = n),
            position = position_dodge(width = 0.9),
            vjust = -0.25) +
  ggtitle("Top 50 Keywords for AFWERX Companies")

gg_top_50

AFWERX Cohort Keyword Log Odds Analysis

Now lets take a look at which keywords associate with which cohorts disproportionately.

First lets build the count.

tbl_keyword_counts <- tbl_company_keywords %>%
  count(type_solicitation, keyword_company_clean_afwerx, sort = T)

Now lets explore the density of the count.

mplot3.x(x = tbl_keyword_counts$n)

Really skews towards low keyword count. Lets make sure the keyword shows up atleast 5 times.

tbl_keyword_counts %>%
  filter(n >= 5) %>%
  pull(n) %>%
  mplot3.x(x = .)

This looks better!

Lets look at the log odds table now.

tbl_lo <-
  tbl_keyword_counts %>%
  filter(n >= 5) %>%
  tidylo::bind_log_odds(set = type_solicitation, feature = keyword_company_clean_afwerx, n = n) %>%
  arrange(desc(log_odds_weighted))

Now lets look at the table

reactable(tbl_lo, filterable = T, sortable = T, searchable = T)

Which AFWERX Words Are Counted Together?

Now lets use some pairwise analysis conditioned on company to see which words often appear together.

tbl_company_keywords %>%
  pairwise_count(feature = name_company_clean, item = keyword_company_clean_afwerx) %>%
  arrange(desc(n)) %>% 
  reactable(filterable = T, searchable = T)

hc_cor_key <- 
  tbl_company_keywords %>%
  count(name_company_clean, keyword_company_clean_afwerx) %>%
  pairwise_cor(item = name_company_clean, feature = keyword_company_clean_afwerx) %>%
  filter(correlation > .70) %>%
  graph_from_data_frame() %>%
  hchart() %>% 
  hc_add_theme(hc_theme_darkunica()) %>% 
  hc_title(text = "Highly Correlated Afwerx Portfolio Company by Keywords") %>% 
  hc_xAxis(visible = F) %>% 
  hc_yAxis(visible = F)

hc_cor_key

Acquire 2021 Budget Data

First step is to acquire the data.

df_budget <- dod_years_budgets(budget_years = 2021, snake_names = T)

[1] “FY 2019” “FY 2020” “FY 2021”
[4] “FY 2020 OCO ENACTMENT” “FY 2020 EMERGENCY” “FY 2021 OCO”
[1] “EXHIBIT M-1” “FY 2019 (BASE + OCO)”
[3] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[5] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [7] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [9] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[11] “FY 2021 TOTAL (BASE + OCO)”
[1] “O&M TITLE PLUS INDEFINITE” “O&M TITLE”
[3] “INDEFINITE ACCOUNTS” “FY 2019 (BASE + OCO)”
[5] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[7] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [9] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [11] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[13] “FY 2021 TOTAL (BASE + OCO)”
[1] “EXHIBIT P-1” “FY 2019 (BASE + OCO)”
[3] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[5] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [7] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [9] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[11] “FY 2021 TOTAL (BASE + OCO)”
[1] “EXHIBIT P-1R” “FY 2019 (BASE + OCO)”
[3] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[5] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [7] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [9] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[11] “FY 2021 TOTAL (BASE + OCO)”
[1] “EXHIBIT R-1” “FY 2019 (BASE + OCO)”
[3] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[5] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [7] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [9] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[11] “FY 2021 TOTAL (BASE + OCO)”
[1] “RF TITLE” “FY 2019 (BASE + OCO)”
[3] “FY 2020 BASE ENACTED” “FY 2020 EMERGENCY”
[5] “FY 2020 OCO ENACTED” “FY 2020 TOTAL ENACTED (BASE+EME” [7] “FY 2021 BASE” “FY 2021 OCO FOR BASE REQUIREMEN” [9] “FY 2021 OCO FOR DIRECT WAR AND” “FY 2021 TOTAL OCO”
[11] “FY 2021 TOTAL (BASE + OCO)”

Lets take a look at it.

skim(df_budget)

Variable type: character

Variable type: logical

Variable type: numeric